home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-rec.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-04  |  16.8 KB  |  791 lines
  1. /*  $Id: pl-rec.c,v 1.26 1998/02/04 16:22:58 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: recorded database (record[az], recorded, erase)
  8. */
  9.  
  10. /*#define O_SECURE 1*/
  11. #include "pl-incl.h"
  12.  
  13. forwards RecordList lookupRecordList(word);
  14. forwards RecordList isCurrentRecordList(word);
  15.  
  16. #define RECORDA 0
  17. #define RECORDZ 1
  18.  
  19. static RecordList recordTable[RECORDHASHSIZE];
  20. static int      dirtyrecords;
  21.  
  22. void
  23. initRecords(void)
  24. { register RecordList *l;
  25.   register int n;
  26.  
  27.   for(n=0, l=recordTable; n < (RECORDHASHSIZE-1); n++, l++)
  28.     *l = makeTableRef(l+1);
  29.   dirtyrecords = 0;
  30. }
  31.  
  32.  
  33. static RecordList
  34. lookupRecordList(register word key)
  35. { int v = pointerHashValue(key, RECORDHASHSIZE);
  36.   register RecordList l;
  37.  
  38.   for(l=recordTable[v]; l && !isTableRef(l); l = l->next)
  39.   { if (l->key == key)
  40.       return l;
  41.   }
  42.   l = (RecordList) allocHeap(sizeof(struct recordList) );
  43.   l->next = recordTable[v];
  44.   recordTable[v] = l;
  45.   l->key = key;
  46.   l->firstRecord = l->lastRecord = (Record) NULL;
  47.   l->type = RECORD_TYPE;
  48.   l->references = 0;
  49.   l->flags = 0;
  50.  
  51.   return l;
  52. }
  53.  
  54.  
  55. static RecordList
  56. isCurrentRecordList(register word key)
  57. { int v = pointerHashValue(key, RECORDHASHSIZE);
  58.   register RecordList l;
  59.  
  60.   for(l=recordTable[v]; l && !isTableRef(l); l = l->next)
  61.   { if (l->key == key)
  62.       return l;
  63.   }
  64.   return NULL;
  65. }
  66.  
  67.  
  68. static void
  69. cleanRecordList(RecordList rl)
  70. { Record *p = &rl->firstRecord;
  71.   Record r = *p;
  72.  
  73.   while(r)
  74.   { if ( r->erased )
  75.     { *p = r->next;
  76.       freeRecord(r);
  77.       dirtyrecords--;
  78.       DEBUG(2, Sdprintf("Deleted record, %d dirty left\n", dirtyrecords));
  79.     } else
  80.     { p = &r->next;
  81.     }
  82.     r = *p;
  83.   }
  84. }
  85.  
  86.  
  87.          /*******************************
  88.          *        HEAP STORAGE    *
  89.          *******************************/
  90.  
  91.  
  92. #ifndef offsetof
  93. #define offsetof(structure, field) ((int) &(((structure *)NULL)->field))
  94. #endif
  95.  
  96. #define SIZERECORD  offsetof(struct record, buffer[0])
  97.  
  98. typedef struct
  99. { tmp_buffer code;            /* code buffer */
  100.   tmp_buffer vars;            /* variable pointers */
  101.   int         size;            /* size on global stack */
  102.   int         nvars;            /* # variables */
  103. } compile_info, *CompileInfo;
  104.  
  105.  
  106. #define    PL_TYPE_VARIABLE    (1)    /* variable */
  107. #define PL_TYPE_ATOM        (2)    /* atom */
  108. #define PL_TYPE_INTEGER          (3)    /* big integer */
  109. #define PL_TYPE_TAGGED_INTEGER  (4)    /* tagged integer */
  110. #define PL_TYPE_FLOAT          (5)    /* double */
  111. #define PL_TYPE_STRING          (6)    /* string */
  112. #define PL_TYPE_COMPOUND    (7)    /* compound term */
  113.  
  114. static void
  115. compile_term_to_heap(Word p, CompileInfo info)
  116. { word w;
  117.  
  118. right_recursion:
  119.   w = *p;
  120.  
  121.   switch(tag(w))
  122.   { case TAG_VAR:
  123.     { int n = info->nvars++;
  124.  
  125.       *p = (n<<7)|TAG_ATOM|STG_GLOBAL;
  126.       addUnalignedBuffer(&info->vars, p, Word);
  127.       addBuffer(&info->code, PL_TYPE_VARIABLE, char);
  128.       addUnalignedBuffer(&info->code, n, int);
  129.  
  130.       return;
  131.     }
  132.     case TAG_ATOM:
  133.     { if ( storage(w) == STG_GLOBAL )
  134.       { int n = ((long)(w) >> 7);
  135.  
  136.     addBuffer(&info->code, PL_TYPE_VARIABLE, char);
  137.     addUnalignedBuffer(&info->code, n, int);
  138.       } else
  139.       { addBuffer(&info->code, PL_TYPE_ATOM, char);
  140.     addUnalignedBuffer(&info->code, w, atom_t);
  141.       }
  142.       return;
  143.     }
  144.     case TAG_INTEGER:
  145.     { long val;
  146.  
  147.       if ( isTaggedInt(w) )
  148.       { val = valInt(w);
  149.     addBuffer(&info->code, PL_TYPE_TAGGED_INTEGER, char);
  150.       } else
  151.       { info->size += sizeof(long)/sizeof(word) + 2;
  152.     val = valBignum(w);
  153.     addBuffer(&info->code, PL_TYPE_INTEGER, char);
  154.       }
  155.       
  156.       addUnalignedBuffer(&info->code, val, long);
  157.       return;
  158.     }
  159.     case TAG_STRING:
  160.     { Word f  = addressIndirect(w);
  161.       int n   = wsizeofInd(*f);
  162.       int pad = padHdr(*f);        /* see also sizeString() */
  163.       int l   = n*sizeof(word)-pad;
  164.  
  165.       info->size += n+2;
  166.       addBuffer(&info->code, PL_TYPE_STRING, char);
  167.       addUnalignedBuffer(&info->code, l, int);
  168.       addMultipleBuffer(&info->code, f+1, n, word);
  169.       
  170.       return;
  171.     }
  172.     case TAG_FLOAT:
  173.     { double val = valReal(w);
  174.  
  175.       info->size += sizeof(double)/sizeof(word) + 2;
  176.       addBuffer(&info->code, PL_TYPE_FLOAT, char);
  177.       addUnalignedBuffer(&info->code, val, double);
  178.  
  179.       return;
  180.     }
  181.     case TAG_COMPOUND:
  182.     { Functor f = valueTerm(w);
  183.       int arity = arityFunctor(f->definition);
  184.  
  185.       info->size += arity+1;
  186.       addBuffer(&info->code, PL_TYPE_COMPOUND, char);
  187.       addUnalignedBuffer(&info->code, f->definition, word);
  188.       p = f->arguments;
  189.       for(; --arity > 0; p++)
  190.       { compile_term_to_heap(p, info);
  191.       }
  192.       goto right_recursion;
  193.     }
  194.     case TAG_REFERENCE:
  195.       p = unRef(w);
  196.       goto right_recursion;
  197.   }
  198. }
  199.  
  200.  
  201.  
  202. Record
  203. compileTermToHeap(term_t t)
  204. { compile_info info;
  205.   Record record;
  206.   Word *p;
  207.   int n, size;
  208.  
  209.   SECURE(checkData(valTermRef(t)));
  210.  
  211.   initBuffer(&info.code);
  212.   initBuffer(&info.vars);
  213.   info.size = 0;
  214.   info.nvars = 0;
  215.  
  216.   compile_term_to_heap(valTermRef(t), &info);
  217.   n = info.nvars;
  218.   p = (Word *)info.vars.base;
  219.   while(--n >= 0)
  220.     setVar(**p++);
  221.   discardBuffer(&info.vars);
  222.   
  223.   size = SIZERECORD + sizeOfBuffer(&info.code);
  224.   record = allocHeap(size);
  225.   record->gsize = info.size;
  226.   record->nvars = info.nvars;
  227.   record->size = size;
  228.   record->erased = FALSE;
  229.   memcpy(record->buffer, info.code.base, sizeOfBuffer(&info.code));
  230.   discardBuffer(&info.code);
  231.  
  232.   return record;
  233. }
  234.  
  235.  
  236. typedef struct
  237. { char *data;
  238.   Word *vars;
  239.   Word gstore;
  240. } copy_info, *CopyInfo;
  241.  
  242. #define fetchBuf(b, var, type) \
  243.         do \
  244.         { *var = *((type *)(b)->data); \
  245.           (b)->data += sizeof(type); \
  246.         } while(0)
  247. #define fetchUnalignedBuf(b, var, type) \
  248.         do \
  249.         { memcpy(var, (b)->data, sizeof(type)); \
  250.           (b)->data += sizeof(type); \
  251.         } while(0)
  252. #define fetchMultipleBuf(b, var, times, type) \
  253.         do \
  254.         { int _n = (times) * sizeof(type); \
  255.           memcpy(var, (b)->data, _n); \
  256.           (b)->data += _n; \
  257.         } while(0)
  258.  
  259.  
  260. #ifndef WORDS_PER_DOUBLE
  261. #define WORDS_PER_DOUBLE ((sizeof(double)+sizeof(word)-1)/sizeof(word))
  262. #endif
  263.  
  264. static void
  265. copy_record(Word p, CopyInfo b)
  266. { int tag;
  267.  
  268. right_recursion:
  269.   fetchBuf(b, &tag, char);
  270.   switch(tag)
  271.   { case PL_TYPE_VARIABLE:
  272.     { int n;
  273.  
  274.       fetchUnalignedBuf(b, &n, int);
  275.       if ( b->vars[n] )
  276.       { if ( p > b->vars[n] )        /* ensure the reference is in the */
  277.       *p = makeRef(b->vars[n]);    /* right direction! */
  278.     else
  279.     { setVar(*p);            /* wrong way.  make sure b->vars[n] */
  280.       *b->vars[n] = makeRef(p);    /* stays at the real variable */
  281.       b->vars[n] = p;
  282.     }
  283.       } else
  284.       {    setVar(*p);
  285.     b->vars[n] = p;
  286.       }
  287.       
  288.       return;
  289.     }
  290.     case PL_TYPE_ATOM:
  291.     { atom_t val;
  292.  
  293.       fetchUnalignedBuf(b, &val, atom_t);
  294.       *p = val;
  295.  
  296.       return;
  297.     }
  298.     case PL_TYPE_TAGGED_INTEGER:
  299.     { long val;
  300.  
  301.       fetchUnalignedBuf(b, &val, long);
  302.       *p = consInt(val);
  303.  
  304.       return;
  305.     }
  306.     case PL_TYPE_INTEGER:
  307.     { long val;
  308.  
  309.       fetchUnalignedBuf(b, &val, long);
  310.       *p = consPtr(b->gstore, TAG_INTEGER|STG_GLOBAL);
  311.       *b->gstore++ = mkIndHdr(1, TAG_INTEGER);
  312.       *b->gstore++ = val;
  313.       *b->gstore++ = mkIndHdr(1, TAG_INTEGER);
  314.  
  315.       return;
  316.     }
  317.     case PL_TYPE_FLOAT:
  318.     { double val;
  319.  
  320.       fetchUnalignedBuf(b, &val, double);
  321.       *p = consPtr(b->gstore, TAG_FLOAT|STG_GLOBAL);
  322.       *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
  323.       memcpy(b->gstore, &val, WORDS_PER_DOUBLE * sizeof(word));
  324.       b->gstore += WORDS_PER_DOUBLE;
  325.       *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
  326.  
  327.       return;
  328.     }
  329.     case PL_TYPE_STRING:
  330.     { int len, lw, pad;
  331.       word hdr;
  332.  
  333.       fetchUnalignedBuf(b, &len, int);
  334.       lw = (len+sizeof(word))/sizeof(word); /* see globalNString() */
  335.       pad = (lw*sizeof(word) - len);
  336.       *p = consPtr(b->gstore, TAG_STRING|STG_GLOBAL);
  337.       *b->gstore++ = hdr = mkStrHdr(lw, pad);
  338.       memcpy(b->gstore, b->data, lw * sizeof(word));
  339.       b->gstore += lw;
  340.       *b->gstore++ = hdr;
  341.       b->data += lw * sizeof(word);
  342.  
  343.       return;
  344.     }
  345.     case PL_TYPE_COMPOUND:
  346.     { word fdef;
  347.       int arity;
  348.  
  349.       fetchUnalignedBuf(b, &fdef, word);
  350.       arity = arityFunctor(fdef);
  351.  
  352.       *p = consPtr(b->gstore, TAG_COMPOUND|STG_GLOBAL);
  353.       *b->gstore++ = fdef;
  354.       p = b->gstore;
  355.       b->gstore += arity;
  356.       for(; --arity > 0; p++)
  357.     copy_record(p, b);
  358.       goto right_recursion;
  359.     }
  360.   }
  361. }
  362.  
  363.  
  364. void
  365. copyRecordToGlobal(term_t copy, Record r)
  366. { copy_info b;
  367.   Word *p;
  368.   int n;
  369.  
  370.   b.data = r->buffer;
  371.   if ( r->nvars > 0 )
  372.   { if ( !(b.vars = alloca(sizeof(Word) * r->nvars)) )
  373.       fatalError("alloca() failed");
  374.     for(p = b.vars, n=r->nvars; --n >= 0;)
  375.       *p++ = 0;
  376.   }
  377.   b.gstore = allocGlobal(r->gsize);
  378.   
  379.   copy_record(valTermRef(copy), &b);
  380.   if ( b.gstore != gTop )
  381.   { Sdprintf("b.gstore = %p, gTop = %p\n", b.gstore, gTop);
  382.     Sdprintf("Term = ");
  383.     pl_write_canonical(copy);
  384.     Sdprintf("\n");
  385.   }
  386.  
  387.   SECURE(checkData(valTermRef(copy)));
  388. }
  389.  
  390.          /*******************************
  391.          *     STRUCTURAL EQUIVALENCE    *
  392.          *******************************/
  393.  
  394. typedef struct
  395. { char *data;
  396.   tmp_buffer vars;
  397. } se_info, *SeInfo;
  398.  
  399.  
  400. static int
  401. se_record(Word p, SeInfo info)
  402. { word w;
  403.   int stag;
  404.  
  405. right_recursion:
  406.   fetchBuf(info, &stag, char);
  407. unref_cont:
  408.   w = *p;
  409.  
  410.   switch(tag(w))
  411.   { case TAG_VAR:
  412.       if ( stag == PL_TYPE_VARIABLE )
  413.       { int n = entriesBuffer(&info->vars, Word);
  414.     int i;
  415.  
  416.     fetchUnalignedBuf(info, &i, int);
  417.     if ( i != n )
  418.       fail;
  419.  
  420.     *p = (n<<7)|TAG_ATOM|STG_GLOBAL;
  421.     addUnalignedBuffer(&info->vars, p, Word);
  422.     succeed;
  423.       }
  424.       fail;
  425.     case TAG_ATOM:
  426.       if ( storage(w) == STG_GLOBAL )
  427.       { if ( stag == PL_TYPE_VARIABLE )
  428.     { int n = ((long)(w) >> 7);
  429.       int i;
  430.  
  431.       fetchUnalignedBuf(info, &i, int);
  432.       if ( i == n )
  433.         succeed;
  434.     }
  435.     fail;
  436.       } else if ( stag == PL_TYPE_ATOM )
  437.       { atom_t val;
  438.  
  439.     fetchUnalignedBuf(info, &val, atom_t);
  440.     if ( val == w )
  441.       succeed;
  442.       }
  443.  
  444.       fail;
  445.     case TAG_INTEGER:
  446.       if ( isTaggedInt(w) )
  447.       { if ( stag == PL_TYPE_TAGGED_INTEGER )
  448.     { long val = valInt(w);
  449.       long v2;
  450.  
  451.       fetchUnalignedBuf(info, &v2, long);
  452.       if ( v2 == val )
  453.         succeed;
  454.     }
  455.       } else
  456.       { if ( stag == PL_TYPE_INTEGER )
  457.     { long val = valBignum(w);
  458.       long v2;
  459.  
  460.       fetchUnalignedBuf(info, &v2, long);
  461.       if ( v2 == val )
  462.         succeed;
  463.     }
  464.       }
  465.       fail;
  466.     case TAG_STRING:
  467.       if ( stag == PL_TYPE_STRING )
  468.       { int len;
  469.     char *s1 = valString(w);
  470.     word m  = *((Word)addressIndirect(w));
  471.     int wn  = wsizeofInd(m);
  472.  
  473.     fetchUnalignedBuf(info, &len, int);
  474.     if ( wn == len && memcmp(s1, info->data, len * sizeof(word)) == 0 )
  475.     { info->data += len * sizeof(word);
  476.       succeed;
  477.     }
  478.       }
  479.       fail;
  480.     case TAG_FLOAT:
  481.       if ( stag == PL_TYPE_FLOAT )
  482.       { double val = valReal(w);
  483.     
  484.     if ( memcmp(&val, info->data, sizeof(double)) == 0 )
  485.     { info->data += sizeof(double);
  486.       succeed;
  487.     }
  488.       }
  489.  
  490.       fail;
  491.     case TAG_COMPOUND:
  492.       if ( stag == PL_TYPE_COMPOUND )
  493.       { Functor f = valueTerm(w);
  494.     word fdef;
  495.  
  496.     fetchUnalignedBuf(info, &fdef, word);
  497.     if ( fdef == f->definition )
  498.     { int arity = arityFunctor(fdef);
  499.  
  500.       p = f->arguments;
  501.       for(; --arity > 0; p++)
  502.       { if ( !se_record(p, info) )
  503.           fail;
  504.       }
  505.       goto right_recursion;
  506.     }
  507.       }
  508.  
  509.       fail;
  510.     case TAG_REFERENCE:
  511.       p = unRef(w);
  512.       goto unref_cont;
  513.     default:
  514.       assert(0);
  515.       fail;
  516.   }
  517. }
  518.  
  519.  
  520. int
  521. structuralEqualArg1OfRecord(term_t t, Record r)
  522. { se_info info;
  523.   int n, rval;
  524.   Word *p;
  525.  
  526.   initBuffer(&info.vars);
  527.   info.data = r->buffer + sizeof(char) + sizeof(word);
  528.                     /* skip PL_TYPE_COMPOUND <functor> */
  529.   rval = se_record(valTermRef(t), &info);
  530.   n = entriesBuffer(&info.vars, Word);
  531.   p = (Word *)info.vars.base;
  532.   while(--n >= 0)
  533.     setVar(**p++);
  534.   discardBuffer(&info.vars);
  535.  
  536.   return rval;
  537. }
  538.  
  539.  
  540. bool
  541. freeRecord(Record record)
  542. { freeHeap(record, record->size);
  543.  
  544.   succeed;
  545. }
  546.  
  547.         /********************************
  548.         *       PROLOG CONNECTION       *
  549.         *********************************/
  550.  
  551. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  552. The key is stored as an atom, integer  or functor header as found on the
  553. global-stack. A functor is a type with  the   same  mask as an atom, but
  554. using the STG_GLOBAL storage indicator.  So,   the  first line denotes a
  555. real atom.
  556. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  557.  
  558. bool
  559. unifyKey(term_t key, word val)
  560. { if ( (isAtom(val) && storage(val) != STG_GLOBAL) ||
  561.        isTaggedInt(val) )
  562.     return _PL_unify_atomic(key, val);
  563.  
  564.   return PL_unify_functor(key, (functor_t) val);
  565. }
  566.  
  567.  
  568. word
  569. getKey(term_t key)
  570. { Word k = valTermRef(key);
  571.   deRef(k);
  572.  
  573.   if ( isAtom(*k) || isTaggedInt(*k) )
  574.     return *k;
  575.   else if ( isTerm(*k) )
  576.     return (word)functorTerm(*k);
  577.   else
  578.     return (word)NULL;
  579. }
  580.  
  581.  
  582. word
  583. pl_current_key(term_t k, word h)
  584. { RecordList l;
  585.  
  586.   switch( ForeignControl(h) )
  587.   { case FRG_FIRST_CALL:
  588.       l = recordTable[0];
  589.       break;
  590.     case FRG_REDO:
  591.       l = ForeignContextPtr(h);
  592.       break;
  593.     case FRG_CUTTED:
  594.     default:
  595.       succeed;
  596.   }
  597.  
  598.   for(; l; l = l->next)
  599.   { while(isTableRef(l) )
  600.     { l = unTableRef(RecordList, l);
  601.       if ( !l )
  602.     fail;
  603.     }
  604.     if ( l->firstRecord == NULL || unifyKey(k, l->key) == FALSE )
  605.       continue;
  606.  
  607.     return_next_table(RecordList, l, ;);
  608.   }
  609.  
  610.   fail;
  611. }
  612.  
  613. static bool
  614. record(term_t key, term_t term, term_t ref, int az)
  615. { RecordList l;
  616.   Record copy;
  617.   word k;
  618.  
  619.   if ( !(k = getKey(key)) )
  620.     return warning("record%c/3: illegal key", az == RECORDA ? 'a' : 'z');
  621.  
  622.   l = lookupRecordList(k);
  623.   copy = compileTermToHeap(term);
  624.   copy->list = l;
  625.  
  626.   TRY(PL_unify_pointer(ref, copy));
  627.   if ( !l->firstRecord )
  628.   { copy->next = (Record) NULL;
  629.     l->firstRecord = l->lastRecord = copy;
  630.     succeed;
  631.   }
  632.   if ( az == RECORDA )
  633.   { copy->next = l->firstRecord;
  634.     l->firstRecord = copy;
  635.     succeed;
  636.   }
  637.   copy->next = (Record) NULL;
  638.   l->lastRecord->next = copy;
  639.   l->lastRecord = copy;
  640.  
  641.   succeed;
  642. }
  643.  
  644. word
  645. pl_recorda(term_t key, term_t term, term_t ref)
  646. { return record(key, term, ref, RECORDA);
  647. }
  648.  
  649. word
  650. pl_recordz(term_t key, term_t term, term_t ref)
  651. { return record(key, term, ref, RECORDZ);
  652. }
  653.  
  654. word
  655. pl_recorded(term_t key, term_t term, term_t ref, word h)
  656. { RecordList rl;
  657.   Record record;
  658.   word k;
  659.   term_t copy;
  660.  
  661.   DEBUG(5, Sdprintf("recorded: h=0x%lx, control = %d\n",
  662.             h, ForeignControl(h)));
  663.  
  664.   switch( ForeignControl(h) )
  665.   { case FRG_FIRST_CALL:
  666.       if ( PL_get_pointer(ref, (void **)&record) )
  667.       { if ( !isRecord(record) )
  668.       return warning("recorded/3: Invalid reference");
  669.     if ( !unifyKey(key, record->list->key) )
  670.       fail;
  671.     copy = PL_new_term_ref();
  672.     copyRecordToGlobal(copy, record);
  673.     return PL_unify(term, copy);
  674.       }
  675.       if ( !(k = getKey(key)) )
  676.     return warning("recorded/3: illegal key");
  677.       if ( !(rl = isCurrentRecordList(k)) )
  678.     fail;
  679.       record = rl->firstRecord;
  680.       break;
  681.     case FRG_REDO:
  682.     { RecordList rl;
  683.  
  684.       record = ForeignContextPtr(h);
  685.       rl = record->list;
  686.  
  687.       if ( --rl->references == 0 && true(rl, R_DIRTY) )
  688.       { while(record && record->erased )
  689.       record = record->next;    /* find a valid record */
  690.     cleanRecordList(rl);
  691.       }
  692.       DEBUG(0, assert(rl->references >= 0));
  693.       break;
  694.     }
  695.     case FRG_CUTTED:
  696.     { RecordList rl;
  697.  
  698.       record = ForeignContextPtr(h);
  699.       rl = record->list;
  700.  
  701.       if ( --rl->references == 0 && true(rl, R_DIRTY) )
  702.     cleanRecordList(rl);
  703.     }
  704.       /* FALLTHROUGH */
  705.     default:
  706.       succeed;
  707.   }
  708.  
  709.   copy = PL_new_term_ref();
  710.   for( ;record; record = record->next )
  711.   { mark m;
  712.  
  713.     if ( record->erased )
  714.       continue;
  715.  
  716.     Mark(m);
  717.     copyRecordToGlobal(copy, record);    /* unifyRecordToGlobal()? */
  718.     if ( PL_unify(term, copy) && PL_unify_pointer(ref, record) )
  719.     { if ( !record->next )
  720.     succeed;
  721.       else
  722.       { record->list->references++;
  723.     ForeignRedoPtr(record->next);
  724.       }
  725.     }
  726.     Undo(m);
  727.   }
  728.  
  729.   fail;
  730. }
  731.  
  732.  
  733. word
  734. pl_erase(term_t ref)
  735. { Record record;
  736.   Record prev, r;
  737.   RecordList l;
  738.  
  739.   if ( !PL_get_pointer(ref, (void **)&record) ||
  740.        !inCore(record))
  741.     return warning("erase/1: Invalid reference");
  742.  
  743.   if ( isClause(record) )
  744.   { Clause clause = (Clause) record;
  745.   
  746.     if ( true(clause->procedure->definition, LOCKED) &&
  747.      false(clause->procedure->definition, DYNAMIC) )
  748.       return warning("erase/1: Attempt to erase clause from system predicate");
  749.  
  750.     return retractClauseProcedure(clause->procedure, clause);
  751.   }
  752.   
  753.   if ( !isRecord(record) )
  754.     return warning("erase/1: Invalid reference");
  755.  
  756. #if O_DEBUGGER
  757.   callEventHook(PLEV_ERASED, record);
  758. #endif
  759.  
  760.   l = record->list;
  761.   if ( l->references )            /* a recorded has choicepoints */
  762.   { record->erased = TRUE;
  763.     set(l, R_DIRTY);
  764.     dirtyrecords++;
  765.     DEBUG(2, Sdprintf("%d Delayed record destruction\n", dirtyrecords));
  766.     succeed;
  767.   }
  768.  
  769.   if ( record == l->firstRecord )
  770.   { if ( record->next == (Record) NULL )
  771.       l->lastRecord = (Record) NULL;
  772.     l->firstRecord = record->next;
  773.     freeRecord(record);
  774.     succeed;
  775.   }
  776.  
  777.   prev = l->firstRecord;
  778.   r = prev->next;
  779.   for(; r; prev = r, r = r->next)
  780.   { if (r == record)
  781.     { if ( r->next == (Record) NULL )
  782.         l->lastRecord = prev;
  783.       prev->next = r->next;
  784.       freeRecord(r);
  785.       succeed;
  786.     }
  787.   }
  788.  
  789.   return warning("erase/1: Invalid reference");
  790. }
  791.